Mac100% 1998 November/MAC100-1998-11.ISO.7z/MAC100-1998-11.ISO/ｵﾝﾗｲﾝｿﾌﾄ定点観測/ﾕｰﾃｨﾘﾃｨ/Mops 3.2.sea/Mops 3.2/Mops ƒ/Class

Text File | 1998-06-15 | 77KB | 2,862 lines

¥ High-level class/object implementation.

cr .( loading Class...)


¥ : >classxt            >classCfa  ;
¥ : aligned_addr?        cfa?  ;


(*
Note that the object header format is documented at "object building"
 below.

Jan 96    mrh/imk    Added various mods to object initialization contributed
                by Ivo Krab.

Jul 96    mrh        Mods made to support large_obj_array
        mrh/rh    Incorporated bug fix from Reinout Heeck, so multiple
                 records in unions work.
Sep 96    mrh        Better inline{ - eliminating explicit out-of-line code
                8-way hashing of methods

==============================================================================

Here are all our various class/object formats:



            ================= Object header ======================

Note if the obj is an ivar, it doesn't have a header if it's in a record,
unless the ivar is indexed.  Indexed ivars always have headers, no matter
what, since the indexing code relies on it.


2 bytes        Offset to the indexed area, rel to the class pointer
            (which follows).  If not indexed, this will be 6.

4 bytes        Class pointer (relocatable).

2 bytes        Offset from the data start to the class pointer.
            For simple objects (i.e. not embedded), this is -6.
            For embedded objects, it will be more negative.  Note it
            will always be negative.

(object's data starts here)

For indexed objects, the indexed area (after the ivars) is preceded by
the indexed descriptor (xdesc) with this format:

2 bytes        Width of indexed elements (in bytes)
4 bytes        Number of elements minus 1 (i.e. LIMIT-1).
            The low word of this is used by a CHK instruction
            if #elements is < 32K.

If indexing is attempted on a non-indexed object, the "offset to the
indexed area" will be 6, taking us to the beginning of the object's
data.  The CHK instruction will be done at offset -2 from there, which
won't be the #elements, of course, but will be the offset to the
class pointer WHICH IS ALWAYS NEGATIVE!!  Thus the CHK will always fail!
This was a deliberate trick - about the only place in Mops I've
resorted to anything like this, you'll be glad to know.  (At least I've
described it for you!)

This trick has very limited usefulness now, since all the indexed
methods are now defined in INDEXED-OBJ rather than OBJECT, so normally
an indexed method on a non-indexed class wouldn't be found.  However
the check comes for free, so I've retained it.


        ==============  Class dictionary entry  ================

link/name/hndlr    as for normal colon definitions
4 bytes            call to BLD - the word which builds an object
32 bytes        links to 8-way hashed method chains (relative)
4 bytes            link to ivar chain (relative)
2 bytes            non-indexed data length
2 bytes            width of indexed elements, or zero if not indexed
2 bytes            flags
2 bytes            "xdispl offs" - the ivar offset where indexing starts
                 (used by large_obj_arrays), or zero if none.
4(n+1) bytes    n-way to superclasses (n relocatable addrs terminated by zero)

Flag bits:
    $0001        "large" - indexed with > 64K elements.
    $0002        class is exported from a module


        ==============  ivar dictionary entry  ================

4 bytes        hashed name
4 bytes        link to prev ivar dic entry (relative addr)
4 bytes        class pointer (relocatable)
2 bytes        offset of this ivar's data from the base addr of the class
2 bytes        number of elements if indexed, or zero if not
2 bytes        flags

Flag bits: (zero is rightmost - what will we do on PowerPC?)

bit 0        1 = ivar gets an object header
bit 1        1 = this is a static ivar
bit 2        1 = this is a public ivar

Note: although indexed objects can have 2^^32 elements, we are
assuming that an ivar can't have more than 64K elements.  This is
because we are limiting the maximum ivar length of a class to 64K bytes,
which is a stricter condition.  Would anybody want a longer ivar than
this??

        ==============  Method dictionary entry  ================

4 bytes        hashed name
4 bytes        link to prev method dic entry (relative addr)
2 bytes        flags

    (method code follows - this is the method's cfa here)

Flag bits:

bit 0        1 = private method (note other way round to ivars - we're using
                1 for the unusual case)
bit 7        1 = there's a callFirst and/or callLast method


        ==========================================================
*)


: xx  db ;            ¥ useful!

    26    constant    static_ivar_offs
                            ¥ the offset from the start of the ivar dic
                            ¥  info for a static ivar, to the ivar's data.
                            ¥  The ivar info is 18 bytes long, then the
                            ¥  ivar is instantiated immediately, with the
                            ¥  usual 8-byte object header.  Total: 26.

    0    value    PUB/PRIV    ¥ -1 private, 1 public, 0 default - for ivars and methods
false    value    STATIC?        ¥ true if following ivars are to be static
    0    value    ^COMP_CLASS    ¥ addr of the class we're currently compiling
    0    value    PIVAR        ¥ hashed name of any public ivar we're accessing
    0    value    PIVSEL        ¥ hashed selector of any msg being sent to
                            ¥  to a public ivar

    0    value    NEWOBJECT    ¥ addr of object being created
    0    value    #SUP        ¥ number of superclasses for current class
    0    value    SUPERS_TO_SKIP
    0    value    INITID


variable METAADDR            ¥ will hold relocatable address of pseudoclass
                            ¥  Meta. Used in NW_IVSETUP to find if end
                            ¥  of superclass chain has been reached


¥                ===============================
¥                        UTILITY WORDS
¥                ===============================

: PRIVATE        -1 -> pub/priv  ;        ¥ following methods and ivars will be private
: PUBLIC         1 -> pub/priv  ;        ¥ following methods and ivars will be public

: END_PRIVATE    0 -> pub/priv  ;        ¥ back to the default
: END_PUBLIC    0 -> pub/priv  ;        ¥ ditto


: X    bld  123  ;                ¥ The 123 blocks optimization!

' x @  forget x      constant    CLASSMK        ¥  JSR  bldVec-base(A3)

: EXBASE    $ 4E92  w,  ;    immediate    ¥  JSR  (A2)

: >OBJ  ( cfa -- ^obj )  inline{ 8 +}  ;
: OBJ>  ( ^obj -- cfa )  inline{ 8 -}  ;
            ¥ Note: we don't use >class here, since obj> shouldn't be
            ¥ used for embedded objects, and it is used during obj
            ¥ building when the ^class isn't there yet.

: CHKCLASS    ¥ ( cfa -- cfa )
    class?  ?EXIT
    .id  space  true ?error 80  ;

: ?>CLASS   ( ^obj -- ^class )
    >class  dup 0= ?error 81  ;        ¥ If no legal class ptr, probably
                                    ¥ not an obj addr at all!

¥ the following offsets refer to where a ^class points, i.e. the cfa
¥ of the class.

(*    MFA_offset picks one of the 8 method threads, given a selID.
    The selID is probably not very random in the low byte (since
    selectors all end in ":", so we hash it a little more then pick
    the 3 bits from the result which are already in the right position.

    Note: it took a surprising amount of trial and error to get a
    good extra hash for this particular use!
*)

: MFA_offset  ( selID ^class -- selID ^class MFA_offset )
    over
    dup 5 >> +
    $ 1C and  4+  ;

: MFA  ( SelID ^Class -- SelID MFA )  MFA_offset  + ;

36    constant    IFA_offset

: IFA    inline{ IFA_offset +} ;    ¥ ivar link
: DFA    inline{ 40 +}    ;        ¥ Data len (2 bytes),
                                 ¥  width of indexed elts (2 bytes)
: FFA    inline{ 44 +}    ;        ¥ Flags (2 bytes)
: XOFFA    inline{ 46 +}    ;        ¥ indexing offset for large_obj_arrays (2 bytes)
: SFA    inline{ 48 +}    ;        ¥ Superclass N-way starts here

48    constant    classSize        ¥ total size of class info up to N-way


¥ : GETDLEN        ¥ ( ^obj -- n )  Gets length of object's named ivars
¥    ?>class dfa w@  ;

: (^DLEN)    ¥ ( ^obj -- ^datalen )  This is a low-level word which should
            ¥  normally only be used in the Mops system stuff.  Note it
            ¥  takes ^obj, not ^class, and it doesn't do a module check
            ¥  - it assumes the class is in the same segment as the object.
    ?>class dfa  ;


: (DLEN&XWID)    ( ^class -- dlen xwid )    ¥ Assumes ^class is the true class
        dfa dup  w@  swap  2+ w@  ;        ¥  addres, not main dictionary address
                                        ¥  of exported class in module
                                        ¥ Only intended for internal use!

: DLEN&XWID        ( ^class -- dlen xwid )
        ?>classInMod
        (dlen&xwid)
        ?unHoldMod  ;


: DLEN    dlen&xwid  drop  ;
: XWID    dlen&xwid  nip   ;

: IVARLEN    postpone dlen  ;    immediate        ¥ an alias for dlen

: OBJLEN    ¥ ( -- objlen )  Computes total data length of current object.

    ^base (^dlen)  dup w@  swap 2+ w@  ?dup
    IF  idxBase 4- @ 1+  *  + 4+  THEN   ;


: ?>MAINDIC  { ^class -- '^class }
        ¥ If ^class is exported from a module, we return the main dic
        ¥ equivalent.  If it's not exported, we return it unchanged.
        ¥ We need this word since for exported classes, we need to use the
        ¥ imported address (in the main dictionary) as the class pointer
        ¥ in a new object or an ivar dic entry (so that the module will be
        ¥ invoked properly when a method is sent to the object.

    ^class ffa 1+ 1 btest
    IF        ^class >name n>count sfind drop
    ELSE    ^class
    THEN  ;


: LARGE_OBJ_ARRAY_CHECK  { ^class offs ¥ xoffs  -- offs xdispl-offs }

¥ Following <findm> or <IVfindm>, we check if this is a large_obj_array,
¥  in which case we might have to map the obj/ivar into the indexed area:

    ^class xoffa w@  -> xoffs    ¥ offs where remapping ends - are we before that?
    ^class searchedClass <>
    offs xoffs <  and
    IF            ¥ yes - remapping necessary.  Return offs to xdispl ivar
        offs  xoffs 12 +
    ELSE        ¥ no - normal case - just return zero
        offs 0
    THEN
;


: <findM>  { selID ^class ¥ cfa offs  -- cfa offs xdispl-offs }

(*    Factored out from clFndm and objFindm.  Finds a method's cfa given a
    selID and a class address, which has already been converted to a module
    addr if necessary.

    offs will be nonzero if the method turns out to belong to a superclass
    with a non-zero offset in the object - i.e. an embedded object.
    If it's a large_obj_array, and the object is in the indexed area,
    xdispl-offs will be nonzero.  This allows the caller to compile
    code to add the offset to the selected element.
*)

    ^class -> objClass                    ¥ used in error msgs and inline binding

    selID ^class MFA_offset true  (findm)
    NIF  cr  ^class .id  108 die        ¥ "method not found"
    THEN
    -> cfa  -> offs
    offs -> emb_obj_offs                ¥ may need this in inline binding
    cfa
    ^class offs  large_obj_array_check
;


: <findIV>  { selID ^class ¥ ^ivar offs xoffs -- ^ivar offs xdispl-offs T | -- F  }

(*    Basic routine to look for an ivar.  It's not an error if we don't find it,
    so we return a flag.
*)
    selID ^class IFA_offset false (findm)  NIF  false  EXIT  THEN
    8 -  -> ^ivar  -> offs        ¥ note - (findm) has returned the base
                                ¥  offs here.
    ^ivar 12 + w@  ++> offs
    ^ivar
    ^class offs  large_obj_array_check
    true
;


: ClFindM  { selID ^class ¥ cfa offs xoffs -- cfa offs xdispl-offs }

(*    finds a method's cfa given a selID and a class address, which hasn't
    been checked for being in a module.  The returned results are as
    described above for <findM>.
*)
    ^class ?>classInMod -> ^class
    selID ^class  <findM>
;


: ObjFindM  { selID ^obj ¥ ^class cfa offs xoffs  -- cfa offs xdispl-offs
                                                | -- cfa offs 0 }

(* Finds a method's xt given a selID and an obj addr.  The returned
    results are as described above for <findM>.
*)
    ^obj >class  -> ^class
    ^class NIF  81 die  THEN            ¥ "not an object"
    selID ^class  <findM>
;


: IVFindM    ¥ ( selID ^ivar -- xt offs xdispl-offs )
¥  Looks for a method in an ivar.

    8 + @abs        ¥ addr of ivar's class
    clFindm  ;


: SEND  { ^obj selID ¥ svMB -- }    ¥  Executes a method given its sel ID.  Used
                                    ¥      in late binding.  Can also be used if you
                                    ¥   have a dynamically determined method ID.
    modBase -> svMB
    selID ^obj  objFindM
    ?dup
    IF        ^obj + dup @ + +
    ELSE    ^obj +
    THEN
    swap  ex-method
    svMB -> modBase  ;


: (DEFER)  ( ^obj -- )        ¥ Looks up SelID at IP and runs the method.
                            ¥  Used in late binding.
    @(ip)  send  ;


0 -> quitvec   0 -> abortvec   0 -> objInit        ¥ clear vectors
' pfind  -> ufind


: ?CLASS        ¥ Error if not compiling a class definition.
    cstate 0=  ?error 115  ;



(*    IVFIND is called when we've parsed a selector.  It determines if the next
    word is an ivar.
    Note: if found, <findIV> returns the equivalent of the cfa of
    a method, which for ivars, is the addr of the class pointer.
*)

: ivFind  { str-addr ¥ xdispl-offs -- ^ivar offs xdispl-offs T |  -- str-addr F }
    str-addr
    cstate  NIF  false  EXIT  THEN
    hash ^comp_class  <findIV>        ¥ ( ^ivar offs xdispl-offs  T  |  F )
    IF        true
    ELSE    DP  false
    THEN
;


¥ TOfind looks for a temp (local) object.

: TOfind  { str-addr -- ^ivar offs T | -- str-addr F  }
    str-addr
    tmpObjs  NIF  false  EXIT  THEN
    hash
    tmpObjs <findIV>
    IF                    ¥ ( -- ^ivar offs xdispl-offs )
            drop        ¥ xdispl-offs must be zero for class Dummy
            dup $ FFFE >=
            IF            ¥ self or super - mustn't match these in class Dummy!
                2drop  str-addr false  EXIT
            THEN
            true
    ELSE    str-addr false
    THEN
;

(*
LocFind will be called from Ufind, which is the vector that gets first
shot at recognizing a word.
It looks at all the possibilities involving local names, which are
not in the regular dictionary.  These possibilities are: named parms/locals,
local objects, and if a class is being compiled, ivars of this class.

In the latter case, we arrange for the ivar's address to
be pushed at run time simply by compiling ^base followed by an add of the
ivar's offset - our code generation will produce optimal code for this.
We then have to return the xt of some word to keep FIND happy - we don't
need to compile anything else, so we use the xt of NULL and return a 1
instead of True - this makes FIND think it's immediate.  So NULL is
executed immediately, which does precisely nothing.

The one exception to this is if the "ivar" turns out to be SELF or SUPER
- in this case we need to call the nucleus word SELF which works out
the right base address (this is what happened pre-2.5).  Here we keep
FIND happy by pushing the xt of SELF and True, so that it sees we've
found SELF.
*)

: LocFind        ¥ ( str-addr -- cfa T  |  -- str-addr F )
    Pfind    ?dup  ?EXIT                    ¥ Found a named parm/local
    TOfind
    IF                                    ¥ Found temp obj
        nip                                ¥ Don't need its dic addr
        postpone locReg  postpone literal  postpone +
        ['] null  1   EXIT
    THEN

¥ Now we look for an ivar name

    cstate  NIF  false  EXIT  THEN        ¥ search fails if we're not compiling
                                        ¥  a class

¥ mybugtest if db then

    dup hash ^comp_class IFA_offset false  (findm)
    IF                                    ¥ Found ivar
        nip nip                            ¥ don't need embedded obj offs or
                                        ¥  string addr
        4+ w@                            ¥ ivar offset
        dup $ FFFE >=                    ¥ is it SELF or SUPER (just used in
                                        ¥  isolation)?
        IF    drop  ['] self  true  EXIT
        THEN
        postpone ^base postpone literal  postpone +
        ['] null  1
    ELSE    false
    THEN  ;


: ILFA     ( infa -- ilfa )    4+  ;


: ^ICLASS  ( infa -- ^class | 0 )
    8 + dup @ NIF   drop 0   ELSE   @abs ?>classInMod   THEN  ;


: IOFFS    ( infa -- ioffs )    12 + w@  ;
: I#ELS    ( infa -- #els )    14 + w@  ;
: IFFA     ( infa -- iffa )    inline{ 16 +}  ;


: ^NEXTIVAR    ¥ ( infa -- infa' )
    ilfa  displace  ;


¥                        ========================
¥                                BINDING
¥                        ========================

    0    value    OBJ_BASE
    0    value    OBJ_DISPL
    0    value    OBJ_LOCAL_DISPL
    0    value    OBJ_IND

false    value    SELF?


: (OBJ)        ¥ Called from within an inline method.  Passes the object's
            ¥  base and displacement to Handlers to generate the correct
            ¥  address.  Optimization will then apply.

    obj_base obj_displ
    obj_ind  genaddr
    obj_local_displ  postpone literal  postpone +  ;


: (IX)

    (*    Called from within an inline method.  Compiles code to generate
        the indexed address.
        ^comp_class has been set by inl_bind to the class of the obj
        we're binding to.  One tricky point is that to access the indexed
        area, we have to use the dlen value in this class, not the class
        of the method we're calling (which may be a superclass).  But
        the obj_local_displ has already had the embedded object offset
        added in (if any).  We have to ignore this, since we're using
        the object's class, not the method's.  When the method was found,
        the value emb_obj_offs was set to this offset, so we subtract
        it here.
    *)

    ^comp_class dlen&xwid  swap
    self?
    IF  drop  -1  ELSE  aligned  6 +  THEN
    obj_base obj_displ obj_local_displ
    emb_obj_offs -
    obj_ind  ^comp_class ffa w@
    genxaddr  ;


: ^BASE
    compinline?
    IF        (obj)
    ELSE    postpone ^base
    THEN  ;            immediate


: ^ELEM
    compinline?
    IF        (ix)
    ELSE    postpone ^elem
    THEN  ;            immediate


: OBJ    postpone ^base  ;    immediate        ¥ for backward compatibility
: IX    postpone ^elem  ;    immediate        ¥ ditto


local  EARLY_BIND  { oCfa oBase oDispl oLDispl oind slf? ¥ ^mod ptr -- }


: INL_BIND    ¥ ( -- b )
    ¥ In-line code to be compiled for this method.
    ¥ But note, we don't do it if obj_base is zero, meaning that
    ¥ we have put the ^obj in A0 as a temporary.  Some inline
    ¥ methods could cause a clash on A0.  So in this case we
    ¥ call the out-of-line code - we return true so that this
    ¥ will be done by NORM_BIND.  Otherwise we return false.

    obj_base
    NIF                                    ¥ Update cfa to the out-of-line code
        oCfa 2+ dup c@ + aligned  -> oCfa  true
    ELSE
        ^comp_class  cstate  self?                ¥ Save over upcoming evaluate
        slf? NIF  objClass -> ^comp_class  THEN    ¥ Set ^comp_class and cstate
        true -> cstate                            ¥  so ivars are accessible
        slf? -> self?
        oCfa  (compinl)
        -> self?  -> cstate  -> ^comp_class        ¥ Restore
        false
    THEN  ;


: SETUP_MODULE_BIND
    heldMod
    @ @            ¥ get mod handle and dereference - addr of mod start
    SAmask and  -> ^mod
    ^mod 8 + -> ptr            ¥ self-rel addr of exports table
    ptr @ ++> ptr            ¥ ptr -> start of table
    0 -> methIndex
    BEGIN
        ptr @ dup 0< ?error 198
        ^mod +  oCfa =
    NWHILE
        4 ++> methIndex  4 ++> ptr
    REPEAT
;


: NORM_BIND
    heldMod IF  setup_module_bind  THEN
    oCfa  (obj)  EB  ;


:loc  EARLY_BIND        ¥ { oCfa oBase oDispl oLDispl oind slf? -- }
    obj_base  obj_displ  obj_local_displ  obj_ind        ¥ Save
    oBase    -> obj_base            oDispl    -> obj_displ
    OLdispl    -> obj_local_displ    oind    -> obj_ind
    oCfa w@  inlMk =
    IF  inl_bind  ELSE  true  THEN
    IF  norm_bind  THEN
    -> obj_ind  -> obj_local_displ
    -> obj_displ  -> obj_base                            ¥ Restore
;loc


: BIND_TO_OBJ  { cfa ^obj offs -- }
    cfa
    -1                    ¥ -1 as "base" signals handlers to generate
    ^obj                ¥  a normal dic addr.  We still carry the
                        ¥  offs here since if we need to access the
                        ¥  indexed area, we want the original obj addr,
                        ¥  not some embedded object.
    offs  0  false  early_bind  ;

: BIND_TO_STK        ¥ ( cfa -- )
    stkObj  0 swap  false  early_bind  ;

: BIND_TO_IVAR  { cfa offs -- }
    cfa  obj_base  obj_displ
    obj_local_displ offs +
    obj_ind  false  early_bind  ;

: BIND_TO_TMPOBJ  { cfa offs -- }
    cfa
    4        ¥ locReg = D4
    offs
    0 0 false  early_bind  ;

: BIND_TO_SELF  { cfa offs -- }
    cfa  obj_base  obj_displ  offs  obj_ind  true  early_bind  ;



¥                    ===========================
¥                     INITIALIZING NEW OBJECTS
¥                    ===========================

false    value    REC?        ¥ Are we compiling a record?
false    value    UNION?        ¥ Are we compiling a union in a record?
    0    value    UNIONOFFS    ¥ Base offset of the current union


: INIT_OBJ   ( theClass theObj -- )

(*    Performs CLASSINIT: method on object.  Note, we quite deliberately don't
    check if the offset would put us into the indexed area of a large_obj_array.
    This is because we don't want to send CLASSINIT: individually to each of the
    indexed elements, but instead we just send it to the base element.  Then,
    CLASSINIT: in the large_obj_array class copies this to the indexed elements.
*)

    swap
    ( theObj theClass )        initID swap MFA_offset true (findm)
    ( theObj offs xt true )    drop     ¥ Is guaranteed to find CLASSINIT: method
    ( theObj offs xt  )        >r + r>    ¥ Modify obj addr by offs (needed in case
                                    ¥  method is defined in any superclass
                                    ¥  but the first)
    ( theObj' xt )          ex-method
;


: MAKE_HDRS        ( #els ) { theClass theObj ¥ len wid -- }
    ¥ assumes theClass is the true class address, not
    ¥ the main dictionary address of an exported class
    ¥ if theClass is not indexed, there should be no #els on the stack

        theClass (dlen&xwid)  -> wid  -> len

    ¥ first the xdesc (indexed area header), if indexed object
        wid     IF        len aligned -> len
                        theObj len +        ¥ xdesc address: after ivars
        ( #els ^xdesc )    wid over w!            ¥ two bytes: indexed width
        ( #els ^xdesc )    swap 1- swap 2+ !    ¥ four bytes: limit ( #els-1)
                        len 12 +            ¥ offset to indexed area
                                            ¥  to be put in obj header
                ELSE    6                    ¥ standard offset if not indexed
                THEN

        ¥ now the obj header itself
        ( offs )    theObj 8 - w!        ¥ 2 bytes: offset to indexed area
                                        ¥  calculated above
                    theClass ?>maindic    ¥ don't store module addr of class!
                    false -> relocChk?    ¥ obj address could be in heap!
        ( ^class )    theObj 6 - reloc!    ¥ 4 bytes: relocatable class pointer
                    true -> relocChk?
                    -6 theObj 2- w!        ¥ 2 bytes: offset to class pointer --
                                        ¥  always -6 for non-embedded object
;

forward IVSETUP

: NW_IVSETUP  { ^nway baseOffs EOoffs ¥ initEOoffs supClass supOffs -- }

(*    Sets up the groups of ivars for each superclass of the current object/ivar
    being processed. One group for each super of a multiply inherited object.
    Each group we call an "embedded object", which sort of describes what it is.
    On entry ^nway points to the first superclass pointer in the n-way defining
    the multiple inheritance. We repeat the procedure for each superclass until
    the zero marking the end of the n-way is encountered. If the superclass
    is the pseudoclass Meta we don't do anything since it does not have any ivars.
    baseOffs is the position of the current object/ivar's data space relative
    to newObject, the current top-level object being created.
    EOoffs is the offset from newObject at which the current Embedded Object
    starts. When an embedded object starts at a non-zero EOoffs, we put in
    front of it a 2-byte offset to the class pointer. Note that if the
    multiply inherited object is an ivar, there may not be a class pointer!
    This doesn't matter, since it's better for multiply inherited
    objects to always have the same format, wherever they are, and any attempt
    to use the class pointer offset to get the (nonexistent) class pointer
    will most probably be caught by our checks.
*)

¥ From Mops 2.5 on, we're now sending classinit: separately to each
¥  superclass.

    EOoffs -> initEOoffs
    BEGIN
        ^nway @abs ?>classInMod  -> supClass    ¥ may hold a mod
        supClass  MetaAddr @abs  <>
        IF
            baseOffs EOoffs +  initEOoffs -    ¥ Start of dataspace of this
            -> supOffs                        ¥  superclass
            supClass ifa displace            ¥ Infa of first ivar of supClass
            supOffs  EOoffs  ivSetup
            supClass  newObject supOffs +  init_obj
        THEN
        ?unholdMod                                ¥ now finished with the mod
        1cell ++> ^nway
        ^nway @
    WHILE        ¥ another class coming up - store 2-byte ^class offset first
        supClass dfa w@                ¥ dlen of supClass. Faster than using DLEN
        ( dlen ) aligned ++> EOoffs
        EOoffs negate 8 -            ¥ ^class offset for store
        EOoffs initEOoffs -            ¥ offset not already included in baseOffs
        baseOffs + newObject +        ¥ final addr for store
        w!
        2 ++> EOoffs
    REPEAT  ;


(*    IVsetup recursively traverses the tree of nested ivar definitions in a
    class, building headers and indexed area headers where necessary, and
    sending    the CLASSINIT: message to each ivar.

    On entry infa is the nfa of the first ivar in the ivar dictionary of the
    object/ivar whose (sub)ivars we are to set up. The dictionary chain is
    followed to the end, the last link pointing to the Nway superclass pointer.
    baseOffs is the position of the current object/ivar's data space relative
    to newObject, the current top-level object being created.
    EOoffs is non-zero if the ivar whose subivars we are to set up is part
    of an "embedded object", ie. is inherited from a superclass, and this
    superclass is not the first super of the current top-level object.
    This is passed on unmodified in any recursive call and used only by
    NW_IVSETUP to calculate the offset to the class pointer.
    When this word is called, if the object/ivar's class is in a module,
    the module will be held. In some circumstances the caller still needs it.
    The recursive call might require another module to be held, so we have to
    save and restore any module held on entry.
*)

:f IVSETUP        { infa baseOffs EOOffs ¥ ivOffs ivClass -- }

    heldMod                ¥ If class is in module it must not get unheld
                        ¥  while processing so keep address on the stack
    0 -> heldMod        ¥  and clear heldMod so it cannot be unheld

    BEGIN
        infa @ 0>    ¥ A selector is always negative, so a
                    ¥  positive value means the N-way superclass
                    ¥  pointer area ( superclass adresses ),
                    ¥  the endpoint of the ivar dictionary chain

    NWHILE    ¥ build this ivar in object

        infa iffa w@ 2 and            ¥ Static ivar? -> not in obj (bit 1)
        NIF    infa ioffs                ¥ Offset of ivar in owning object
            baseoffs +   -> ivOffs    ¥ Position relative to newObject
            infa ^iclass -> ivClass    ¥ May cause another module to be held
            infa iffa w@ 1 and        ¥ Does it want headers? -> flag bit 0
            IF    infa i#els dup NIF drop THEN
                ivClass
                newObject ivOffs +     ¥ address where headers must be made
                make_hdrs
            THEN
            ?Rdepth                    ¥ Check on recursion depth
            ivClass ifa displace    ¥ Infa of first subivar in
                                    ¥  chain of the currently
                                    ¥  processed ivar object
            ivOffs                    ¥ New base offset of subivar
            0
            ivSetup
            ?unholdMod
            ivClass  newObject ivOffs +  init_obj
        THEN
        infa ^nextivar -> infa
    REPEAT
    infa baseOffs EOoffs  NW_ivSetup    ¥ Set up superclasses
    ( Heldmod )  -> HeldMod
;f


¥ HASHED-HDR lays down the dic header for an ivar or method.
¥ The format is:
¥
¥ 4 bytes        hash
¥ 4 bytes        link (self-relative addr of prev entry)
¥
¥ This entry has to become the first on the chain, so we pass in the
¥ addr of the chain header.

: HASHED-HDR        ¥ ( chain-hdr hash-val -- )
    ,                        ¥ comma in hash value
    dup displace            ¥ get abs addr of prev entry
    displ,                    ¥ comma it in as self-relative addr
    here 8 -  swap  displ!    ¥ update chain header
;


forward    DIC-OBJ

: IVDEF  ( #els ) { iclass ¥ #els wid siz clOffs flags -- }
        ¥ Compiles an ivar dictionary entry.  If indexed, must have
        ¥ < 64K elements.  iclass is the ivar's class.  The class of
        ¥ which this is an ivar, is pointed to by ^class.

    pub/priv 1 =  4 and -> flags    ¥ initial flags - set bit 2 if we're public
    Mword
    ivFind  ?error 117                ¥ same name as another ivar
    drop
    iclass xwid  -> wid                ¥ indexed width of ivar class
    iclass dlen  -> siz                ¥ non-indexed size of this ivar

¥ The initial offset is the current dlen of the class.

    ^comp_class dfa w@  -> clOffs

    ^comp_class  ifa
    here  hash  hashed-hdr            ¥ dic header for ivar

    iclass ?>mainDic  reloc,

¥ Now we need to comma in the 2-byte offset to the ivar within
¥ the class.  First we need to make some adjustments...
¥ Do we need to align the offset:

    siz 1 >                ¥ we do if the ivar size is longer than 1
    wid                    ¥ or if it's indexed
    or
    IF                ¥ We do need to align the offset. Note that if the
                    ¥ ivar class is multiply inherited with >1 superclass
                    ¥ of non-zero length, the ivar size will always be >1.
        clOffs aligned  -> clOffs
    THEN

    iclass ffa 1+ 2 btest        ¥ general?
    dup IF union? ?error 190 THEN    ¥ (can't have a general object in a union)
    rec? not or                    ¥ or not in a record?
    wid or                        ¥ or indexed?
    IF                            ¥ Yes.  In this case the ivar will have
                                ¥  the standard 8-byte object header. So its data
        8 ++> clOffs            ¥  will start 8 bytes later than otherwise.
        1 or> flags                ¥ and we'll mark this in the ivar flags
                                ¥  so make_hdrs will do the right thing.
    THEN
    clOffs  w,

    wid
    IF                ¥ Indexed. Stack has #els.  We calculate the indexed
                    ¥ length of this ivar and increment clOffs.
                    ¥ If we're not in a record, we also need to align the
                    ¥ non-indexed size of the ivar, since the xdesc must
                    ¥ be aligned. (If we're in a record, there won't be an
                    ¥ xdesc.)
        -> #els
        siz aligned  -> siz            ¥ must align the non-indexed size
        #els w,                        ¥ Add #els to ivar dic entry
        #els wid *                    ¥ Get indexed length
        6 +                            ¥ Add 6 for xdesc length
        ++> clOffs                    ¥ Add to clOffs
    ELSE            ¥ Not indexed.
        0 w,
    THEN
    static?
    IF    2 or> flags
    ELSE
        siz ++> clOffs                ¥ Bump clOffs by non-indexed size of ivar
    THEN
    flags w,

(* Now we'll update the class dLen field by whatever we're allocating for this
  ivar - it will then be the offset to the next ivar.  clOffs has the offset
  so far.  In the normal case, this is what goes in dLen.  If we're in
  a union, we MAX it with whatever's already in dLen.  This will leave dLen
  with the longest union element we've reached so far, which will be the final
  value in case we hit the end of the union.
  And if this ivar is static, it will live right where we are in the dic,
  and not in objects of the class, so in this case we leave dLen alone.
*)
    union?
    IF        unionOffs  clOffs  max  -> unionOffs
    ELSE
        static?
        NIF    clOffs  ^comp_class dfa w!
        THEN
    THEN

(* Now we'll check if this ivar is to be static - if so, we'll instantiate
   it right here.
*)

    static?  0EXIT
    wid IF  #els  THEN
    iclass  dic-obj
;


¥                    =================================
¥                            OBJECT BUILDING
¥                    =================================


: CL>LEN ( #els ) { theClass ¥ wid len -- ( #els ) len2 }
                ¥ Gets data length of object given #els and class.
    theClass dlen&xwid  -> wid  -> len
    wid IF    ( #els )  dup 32766 >
        IF  theClass ffa 1+ 0 btest 0= ?error 185  then
         dup  wid *  6 +  len +
    ELSE    len
    THEN  ;


: MAKE_OBJ        ( #els ) { theClass theObj ¥ svHeldMod -- }

    theClass ?>classinMod -> theClass    ¥ Need real class address,
                                        ¥  not main dic equivalent
    heldMod -> svHeldMod                ¥ If class is in module it must
                                        ¥  not get unheld while processing
                                        ¥  so keep the address and clear
    0 -> heldMod                        ¥  heldMod so it cannot be unheld
  ( #els ) theClass theObj make_hdrs    ¥ Actually #els is optional element
                                        ¥  on the stack

    theObj -> newObject                    ¥ base address used by ivsetup
    theClass ifa displace  0 0 ivSetup
    svHeldMod -> heldMod  ?unholdMod    ¥ held module (if any) no longer needed
    theClass theObj init_obj            ¥ do a latebound CLASSINIT:
;                                        ¥  on the object


:f DIC-OBJ  ( #els ) { theClass ¥ ^obj -- }
                ¥ Builds an object in the dictionary.
    here >obj -> ^obj                ¥ Where obj data will start
    theClass  cl>len
    8 +  aligned                    ¥ Required length
    dup room >  ?error 186            ¥ "Not enough room"
      reserve                            ¥ Allocate space for object
    theClass  ^obj  make_obj        ¥ Set up the object
    align-dp  ;f


:f BLD        ¥ ( (#els) -- )    ¥ Builds an object.
                            ¥ Gets called when a class name
                            ¥  is executed
    r> 4-    ¥ Trick! pulling the return address from the stack
            ¥  causes exit to skip the rest of the calling word,
            ¥  which is actually a class definition and does not
            ¥  contain any more executable code.
            ¥  Subtracting 4 gives the class cfa, needed later
            ¥ Note: because of this trick we can't use locals here!

    cstate    IF        ( theClass )  ivDef        ¥ Build an ivar
            ELSE    create_obj                ¥ Create object header - returns
                                            ¥  its data address when called
                    ( theClass )  dic-obj
            THEN
;f




: ]C    true  -> cstate ;        immediate
: C[    false -> cstate ;        immediate


: HASH,        ¥ Compiles hashed word for name at here
    @word  hash ,  ;


¥                    ============================
¥                            :CLASS  etc.
¥                    ============================


¥ Here we set up some quantities so that we can send messages to SELF
¥ or SUPER.  These are treated syntactically as ivars, so to implement
¥ them we actually set up dummy ivars SELF and SUPER.

¥ When we're processing a :CLASS definition, we plug the appropriate
¥ addresses into these ivars.  ^SELF is a word defined to return the
¥ addr of the dummy ivar SELF, so we can do the plugging.
¥ In the case of SUPER, there may be several superclasses, so we have
¥ to go through a class descriptor, since that's the only place we look
¥ for an n-way (a set of addresses).  So we set the "class" of SUPER
¥ to a dummy class SUPCL, which has no ivars or methods (so the search
¥ will pass right on by), and plug the superclass pointer of SUPCL to
¥ point to the current n-way for the superclasses of the class we're
¥ defining.

   0    value    (^SELF)

: ^SELF  ['] (^self)  displace  ;

create    SUPCL                    ¥ dummy superclass
    classCode  here 2 -  w!
    classMk ,
    32 reserve                    ¥ methods links - no methods
    0,                            ¥ ivar link - patched at :CLASS time
    0,                            ¥ data len, indexed width
    0,                            ¥ flags, xdispl-offs
¥ don't need any more!


¥ META is the super class of Object - top of all inheritance

: META    reveal
    [                            ¥ Note, we're still at the cfa
    drop                        ¥ Drop the security marker left by colon
    classCode  here 2 -  w!
    classMk ,                    ¥ class marker goes here
    32 reserve                    ¥ methods links - no methods
    0,                            ¥ ivar link - set to SUPER below
    0,                            ¥ data len, indexed width
    0,                            ¥ flags, indexing offs
    0,                            ¥ super pointer

¥ Now we set up the SELF and SUPER pseudo-ivars.  We set them up exactly
¥ as if they'd been declared as regular ivars in META.  But note we don't
¥ set up any fields past the "offset" field, since they're irrelevant.

create    SUP                        ¥ this is so we can tick it at SuperRef below.

    here                        ¥ ready for SELF link below
    hash, SUPER
    0,                            ¥ empty link
    ' supCl  reloc,                ¥ ^class is dummy supCl (reloc addr reqd)
    $ FFFE  w,                    ¥ "offset" FFFE means SUPER


    here
    hash, SELF
    swap  displ,                ¥ link (points to SUPER)
    0,                            ¥ ^class (gets patched at :CLASS time)
    $ FFFF  w,                    ¥ "offset" FFFF means SELF


dup    ' (^self)    displ!            ¥ ^SELF will now return addr of SELF ivar
    ' meta ifa    displ!

' meta    metaAddr reloc!            ¥ patches so NW_IVSETUP can compare
                                ¥ to decide if the end of the superclass
                                ¥ chain has been reached


    0    value    THISM
    0    value    SUPERM
false    value    1SUPER?


: :CLASS        immediate
    ?exec  header  classCode w,
    here -> ^comp_class
    0 -> pub/priv  0 -> #1st  0 -> #last
    false -> rec?  false -> union?  false -> static?
    307  ;


: MERGE_INFO  { ^sup ivlen ¥ ^wid wid prevWid -- dlen }
    ^sup dlen&xwid  -> wid        ¥ indexed width of this superclass
    ^sup ffa 1+ c@ 5 and        ¥ Merge "general" and "indexed" flags with
    ^comp_class ffa 1+  cset    ¥  what we have already
    wid  0EXIT                    ¥ If this superclass not indexed, we're done

¥ This class is indexed - we need to check if prev classes were indexed
¥  and make sure the widths are compatible.

    ^comp_class dfa 2+  -> ^wid    ¥ Addr of wid field in class we're building
    ^wid w@  -> prevWid            ¥ Get previous width
    wid 32760 u>                ¥ "indexed width" of 32766/7 really means
    IF                            ¥  obj_array.
        prevWid                    ¥ In this case if we already have a width,
        IF        prevWid -> wid    ¥  we use that,
        ELSE    wid
                ivlen  -> wid    ¥ otherwise current ivar len becomes the width.

            ( old wid ) 32766 =
                IF        ¥ large_obj_array - mark boundary between ivars
                        ¥  we are/aren't mapping to the indexed area
                    ivlen aligned  ^comp_class xoffa w!
                    wid aligned 2+  -> wid    ¥ and allow for ^class offset
                                            ¥  field before each element
                THEN
        THEN
    THEN
    prevWid
    NIF     wid  ^wid w!        ¥ If no prev width, set width & we're done
    ELSE    prevWid wid <>  ?error 88        ¥ "Incompatible indexed widths"
    THEN
;


local    (SUP)   { ¥ ivlen ^nway ^sup ^newClass thisLen -- }

: NEXT_SUPER    ( cfa -- )
    chkClass  -> ^sup
    ^sup reloc,                        ¥ Add ^class to n-way
    ^sup ivlen merge_info   -> thisLen
    #sup IF                            ¥ If this is a subsequent class,
        ivlen aligned  2+  -> ivlen    ¥  align and allow for ^class offset
    THEN
    thisLen ++> ivlen                ¥ And add ivar length of new class
    1 ++> #sup  ;


: SUPERS_LOOP
    BEGIN                        ¥ Loop over superclasses:
        '                        ¥ cfa of next item on list
        }or)? IF  drop  EXIT  THEN
        ( cfa )  next_super            ¥ handle next superclass
        1super?  ?EXIT                ¥ Yerk has only one superclass
    AGAIN  ;


:loc  (SUP)
    307 ?pairs                        ¥ Make sure we're in the right place
    DP -> ^newClass
    classMk ,  classSize 4- reserve    ¥ Space for class record
    DP -> ^nway                        ¥ n-way for superclasses will
    0 -> ivlen  0 -> #sup            ¥  start here
    ^newClass 4+ 32 bounds
    DO  ^nway  i displ!  4 +LOOP    ¥ point methods links to nway
    ^nway ^newClass IFA  displ!        ¥ and ivars link
    false -> relocChk?
    supers_loop                        ¥ Loop over superclasses
    0,                                ¥ Terminate n-way
    ['] supCl 4+ 32 bounds
    DO  ^nway  i displ!  4 +LOOP    ¥ we point the method and ivar links
    ^nway  ['] supCl IFA  displ!    ¥  in supcl to the n-way

    ^comp_class xoffa w@  ['] supCl xoffa w!    ¥ and set xoffs in supCl

    ivlen ^comp_class dfa w!        ¥ Set total ivar length
    ^comp_class  ^self 8 +  reloc!    ¥ Store ^class in SELF
    true -> relocChk?
    postpone ]c                        ¥ In a class definition
    308
;loc


: SUPER{        false -> 1super?   (sup)  ;        immediate
: SUPER(        postpone super{  ;                immediate

: <SUPER    true -> 1super?  (sup)    ;            immediate
            ¥ For compatibility with Yerk -- only looks for 1 superclass


: (;CL)
    postpone [   postpone c[
    0 ^self 8 + !  ;


: ;CLASS
    (;cl)  308 ?defn  ;            immediate


   1    value    DFRSELID    ¥ 1 means no late bind going on - otherwise it's
                               ¥  the selector we're late binding with
true    value    SLCTRS?        ¥ Set false to treat selectors as normal words
                            ¥  for full ANSI compatibility

: SEL?        ¥ ( addr -- addr b )  True if word at addr is a selector xxx:
    slctrs?  NIF  false  EXIT  THEN
    dup  count tuck  1- + c@  & :  =
    swap 1 >  and  ;


: GETSELECT            ¥ Gets a selector from the input stream
    mword
    sel?  not ?error 124
    hash
    1 -> dfrSelID  ;


' null    vect    GET1ST&LAST
' null    vect    DoCall1ST
' null    vect    DoCallLast


: M_HEADER  { selID -- }    ¥ Builds a method header and entry sequence.
                            ¥ Note: also called from the assembler.
    selID ^comp_class MFA  selID  hashed-hdr    ¥ Build header
    drop                            ¥ drop extra selID (needed by MFA)
    pub/priv -1 =  1 and  w,        ¥ public/private flag (default is public)
    here -> thisM                    ¥ Remember method cfa
    Mentry  ;                        ¥ Compile the entry sequence



: :M { ¥ selID -- }     immediate        ¥ Start compiling a method.
    true -> method?                    ¥ Used by Handlers
    ?class  305
    rec? ?error 191                    ¥ unmatched '{' in ivar list
    0 -> superM
    getSelect -> selID
    10 -> cstate                    ¥ Means we've read :m, no call_1st yet
    selID ^comp_class MFA_offset true (findm)        ¥ is method already defined?
    IF
        -> superM
        warnings?
        IF    cr  0 -> out
            here count type type# 182         ¥ "Method redefined"
        THEN
        heldMod
        NIF  superM ^comp_class > ?error 183  THEN
                                            ¥ - but if in same class, error
        drop
    THEN
    get1st&last  ?unHoldMod
    selID m_header                    ¥ Build method header
    #1st #last + IF  thisM 1- 7 bset  THEN
    $ 42 -> obj_base                ¥ $ 42 means reg A2 - our obj base
    0 -> obj_displ                    ¥ For any inline method calls
    (:)                                ¥ Start to compile the method
    doCall1st  ;                    ¥ Compile any Call1st calls first


: ;M
    (;)
    #last  IF  true -> method?  doCallLast  defnEnd  false -> method?  THEN
    0 -> #1st  0 -> #last
    305 ?defn  ;        immediate


¥    ============== Local sections for methods ==============

¥ These function just like regular local sections.  The implementation
¥ is nearly the same.

    0    value    MLOC_ADDR


: MLOCAL        ¥ Starts a local section for methods
    local?  ?error 93  1 -> local?        ¥ We change it to the normal -1
                                        ¥ as soon as "{" is read.
    postpone :m
    postpone [
    here -> mloc_addr  10 allot        ¥ Like a forward definition.  We
                                    ¥ save the addr to patch and leave
                                    ¥ room for the JMP instrn which will
                                    ¥ be planted by (patch) below.
    private  ;


: :MLOC        immediate
    public  ?loc  getSelect drop  95
    here  mloc_addr  (patch)    ¥ Like :F
    #PL  IF  PLentry  THEN
    false -> local?                ¥ We do this here so any EXITs
                                ¥  tidy everything up properly
    postpone ]  ;


: ;MLOC        immediate
    (;)  95 ?pairs                ¥ As local? is now false, everything else
    305 ?defn  ;                ¥ gets tidied up by (;)



¥    ================   INDEXED, GENERAL etc.   =================

¥ These are words which can appear in a class declaration, in the
¥ position

¥  :class someClass super{ someSuper }   general

¥ They add attributes to the class.


: INDEXED        ¥ ( width -- )  Sets a class and its subclasses to indexed
    ?class  ^comp_class dfa 2+  w!  ;

: LARGE        ¥ Sets the "large" option on an indexed class, allowing
            ¥ the number of elements to be greater than 32K.

    ?class  ^comp_class ffa 1+  0 bset  ;


: GENERAL

(* Sets the "general" option on a class, which will force an ivar of that class
   to be a general object with a class pointer (so it can be late-bound to) even
   if it's within a record.  Normally you should just not put such ivars in a
   record, but using GENERAL gives a bit of extra security, for classes for which
   you know that they will definitely be late-bound to.  (An attempt to late-bind
   to an ivar without a class pointer will give the "not an object" error at run
   time, which isn't easy to track down.)
   Note that indexed classes are always general anyway.  Also if there's a message
   sent to [self] somewhere in one of the methods, we know that the class *must*
   be general, so in this case we simply set the general attribute.
*)
    ?class  ^comp_class ffa 1+  2 bset  ;


¥                    ===========================
¥                            SELECTORS
¥                    ===========================

¥ First, here are the special-purpose things which can follow a selector.
¥ These can't appear in isolation.

¥ We allow ** and [] as synonyms of [ ] to late-bind to whatever is on the
¥ stack.  Note:  [] is used in JForth.

¥ We also allow [self] as a synonym of [ self ]

: **        83 die  ;        ¥ "Has no meaning unless preceded by a selector"
: []        83 die  ;
: [SELF]    83 die  ;
: SUPER>    83 die  ;
: IVAR>        83 die  ;
: CLASS_AS>    83 die    ;


: ]
    hide  dfrSelID  1 = IF   postpone ]  EXIT  THEN        ¥ if no late bind, this is a
                                                        ¥  standard Forth ]
    dfrSelID NIF  187 die  THEN            ¥ late bound pubilc ivar reference
                                         ¥  not implemented yet!
    251 ?pairs
    state
    IF        postpone (defer)  dfrSelID ,
    ELSE    dfrSelID  send
    THEN
    1 -> dfrSelID  ;        immediate


100        constant    pubIvarTyp        ¥ &&& temp
false    value        need_class?

false    value        implicit_late_bind?        ¥ true for pre-2.7 auto-late-bind
                                            ¥  to locals or values


(* REFTOKEN  ( -- <various> type )
   is called when we've parsed a selector - it determines the type of the
   following word.

   The order of checking determines the priority of names.  Up to 2.6 we
   checked for locals first, but this was a bad idea since a local could
   have the same name as an object, and implicit late binding to locals
   was legal.  This wouldn't show up until a crash at run time.  So now we
   check for temp objects, then ivars, then locals, IF implicit_late_bind?
   is true.

   <various> will be the cfa of whatever came after the selector, or
   ( ^ivar offs xdispl-offs ) for ivars and temp objects (which are treated as ivars
   of the class Dummy).
*)

: REFTOKEN        ¥ ( -- <various> type )

    false -> need_class?
    Mword                                    ¥ grab next word
    TOfind    IF  tmpObjTyp    EXIT  THEN        ¥ check for temp object
    IVfind    IF  ivarTyp        EXIT  THEN        ¥ check for ivar

    implicit_late_bind?
    IF    Pfind    IF  locTyp    EXIT  THEN        ¥ check for named parm/locals
    THEN

    ( here )  dup thread dup @ +  (find)  0=  ?error 125
    dup ['] **            =  IF  lbTyp                            EXIT  THEN
    dup ['] []            =  IF  lbTyp                            EXIT  THEN
    dup ['] [            =  IF  bktTyp                            EXIT  THEN
    dup ['] [self]        =  IF  lbSelfTyp                        EXIT  THEN
    dup ['] super>        =  IF  superTyp                            EXIT  THEN
    dup ['] ivar>        =  IF  pubIvarTyp                        EXIT  THEN
    dup ['] class_as>    =  IF  true -> need_class?  classTyp    EXIT  THEN
    dup hdlr
    CASE
        objCode        OF    >obj  objTyp    ENDOF
        classCode    OF    classTyp        ENDOF
        -90            OF    classTyp        ENDOF        ¥ Exported class
        objPtrCode    OF    objPtrTyp        ENDOF
        valCode        OF    valTyp            ENDOF
        wordCode    OF    wordTyp            ENDOF
        vectCode    OF    wordTyp            ENDOF
                                ¥ Note: here we can treat vectors as words.

        126 die                        ¥ "Not an object name"
    ENDCASE

¥ but if we got wordTyp or valTyp, it's only legal if implicit_late_bind?
¥  is true
    implicit_late_bind?  ?EXIT        ¥ all OK - done
    dup wordTyp =  over valTyp =  or
    IF  126 die  THEN
;



¥ These words handle the binding of a selector to whatever follows it.

(*    FIX_PIVAR does the housekeeping for accessing a public ivar.  When we
    encounter  msg: ivar>  then we store the selector in pivSel, and the
    hashed ivar name in pivar.  We then continue with a zero "selector",
    which signals that it's a public ivar access, and leads to us being
    called back here to fix everything up once we've got the class in which
    the ivar lives.
*)

: FIX_PIVAR  { ^class in_class? ¥ ^ivar offs xdispl-offs -- cfa offs xdispl-offs }

    ^class ?>classInMod -> ^class

    pivar ^class <findIV>            ¥ ( ^ivar offs xdispl-offs true  OR  false )
    0= ?error 192                    ¥ "ivar not found"
    -> xdispl-offs  -> offs  -> ^ivar
    ^ivar iffa w@                     ¥ get ivar flags
    dup 4 and 0=    ?error 193        ¥ ivar not public
    2 and                            ¥ static flag
    in_class?
    IF        0=  ?error 197            ¥ ivar not static
    ELSE    ?error 195                ¥ wrong syntax for public static ivar
    THEN

¥ now we find the method in the ivar's class

    pivSel ^ivar  ivFindm drop        ¥ %%% don't worry about large_obj_arrays
                                    ¥  which are ivars yet!
  ( cfa  offs-within-ivar )
    in_class?
    IF            ¥ for public static ivars, the "offset" we return is
                ¥  actually the ivar's real data address.
        drop ^ivar static_ivar_offs +  -> offs
    ELSE
        ++> offs
     THEN
     offs  xdispl-offs
;


¥ PUBLIC_STATIC_IVAR_REF handles a message bind to a public static ivar
¥ (done via the  msg: ivar> in_class someClass  syntax)

: PUBLIC_STATIC_IVAR_REF
    refToken
    classTyp <>  ?error 196            ¥ class name must follow in_class
    true  fix_pivar drop            ¥ %%% don't worry about large_obj_arrays
                                    ¥  which are public static ivars yet!
    0  bind_to_obj
;


¥ OBJREF handles a reference to a normal object.

: OBJREF  { selID ^obj ¥ cfa offs xdispl-offs -- }

    selID
    IF    selID ^obj  objFindm
    ELSE                ¥ it's a public ivar reference in the referenced object
        ^obj >class  false  fix_pivar
    THEN

  ( cfa offs xdispl-offs )  -> xdispl-offs  -> offs  -> cfa
    xdispl-offs
    IF    ^obj xdispl-offs +  lit-addr
        postpone dup postpone @ postpone +
        offs IF  offs postpone literal  postpone +  THEN    ¥ will normally be zero
        cfa bind_to_stk  EXIT
    THEN

     cfa ^obj offs bind_to_obj
;


¥ IVARREF handles a reference to an ivar.

: IVARREF  { selID ^ivar offs xdispl-offs ¥ cfa stat? -- }

    heldMod  0 -> heldMod                ¥ save
    offs  $ FFFE >=  -> selfRef?        ¥ if self or super.  Allows private
                                        ¥ methods to be found by (findm)
    selfRef?
    IF  supers_to_skip -> sups2skip        ¥ sups2skip is interrogated by (findm).
                                        ¥  This must only be done if self or
                                        ¥  super is the target.
        0 -> offs                        ¥ "real" offset is zero
    ELSE
        ^ivar iffa w@ 2 and  -> stat?    ¥ static ivar?
    THEN

    selID
    IF    selID ^ivar ivFindM            ¥ %%% don't worry about large_obj_arrays
                                    ¥  which are ivars yet!
        selfRef? IF -> xdispl-offs  ELSE drop THEN

        ++> offs                    ¥ add embedded obj base offs to ivar offs
        -> cfa
        0 -> sups2skip  0 -> supers_to_skip

        selfRef?
        IF    xdispl-offs
            IF    postpone ^base  xdispl-offs postpone literal  postpone +
                postpone dup postpone @ postpone +
                cfa  bind_to_stk
            ELSE
                cfa offs bind_to_self  false -> selfRef?
            THEN
            ?unholdMod  -> heldMod   EXIT
        THEN

    ELSE            ¥ it's a public ivar reference within the referenced ivar
        ^ivar ^iclass false  fix_pivar drop        ¥ %%% don't worry about large_obj_arrays
                                                ¥  which are ivars yet!
        ++> offs  -> cfa
    THEN

    stat?
    IF    cfa ^ivar static_ivar_offs  bind_to_obj
        ?unholdMod  -> heldMod  EXIT
    THEN

    xdispl-offs
    IF    postpone ^base  xdispl-offs postpone literal  postpone +
        postpone dup postpone @ postpone +
        offs IF  offs postpone literal  postpone +  THEN    ¥ will normally be zero
        cfa  bind_to_stk
    ELSE
        cfa offs  bind_to_ivar
    THEN
    ?unholdMod  -> heldMod
;


¥ OP/CL is common code factored out of objPtrRef and classRef, which
¥ are very similar.

: OP/CL  { selID ^class ¥ cfa offs xdispl-offs -- }
    selID
    IF    selID ^class clFindm
    ELSE
        ^class  false  fix_pivar
    THEN
    -> xdispl-offs  -> offs  -> cfa

    xdispl-offs
    IF    xdispl-offs postpone literal  postpone +
        postpone dup postpone @ postpone +
    THEN

    offs postpone literal  postpone +
    cfa bind_to_stk
;


¥ OBJPTRREF handles a reference to an object pointer.

: OBJPTRREF  { selID OP-cfa ¥ ^class cfa offs xdispl-offs -- }
    OP-cfa (comp)                    ¥ Compile a fetch of the OP-cfa,
                                    ¥  giving ^obj at run time
    OP-cfa 4+ @  0= ?error 86        ¥ "ObjPtr hasn't had a class specified"
    OP-cfa 4+ @abs  -> ^class
    ^class hdlr -90 =
    IF                                ¥ Class is exported
        ^class 6 + wdisplace        ¥ Addr of module
        compmod =  ?error 84        ¥ It's the module we're compiling -
                                    ¥  this is a no-no, since the ObjPtr
                                    ¥  reference will use the OLD module!
        ^class  ?>classInMod -> ^class
    THEN
    selID ^class  OP/cl
;


¥ CLASSREF handles a reference to a class - this means use the object
¥  whose addr is on the stack, but ASSUME it is of the given class
¥  and early bind, without checking.
¥ The code is very similar to objPtrRef, naturally enough.

: CLASSREF { selID ^class ¥ cfa offs xdispl-offs -- }
    need_class? IF  '  chkClass  -> ^class  false -> need_class?  THEN
    selID ^class  OP/cl
;


¥ TMPOBJREF handles a reference to a temp object.

: TMPOBJREF  { selID ^tmpObj offs ¥ svHeldMod cfa xdispl-offs -- }

    heldMod -> svHeldMod  0 -> heldMod
    selID
    IF    selID ^tmpObj ivFindM
    ELSE
        ^tmpObj 8 + @abs  false  fix_pivar
    THEN
    -> xdispl-offs  ++> offs  -> cfa

    xdispl-offs
    IF    postpone locReg
        xdispl-offs postpone literal  postpone +
        postpone dup postpone @ postpone +
        offs IF  offs postpone literal  postpone +  THEN    ¥ will normally be zero
        cfa  bind_to_stk
    ELSE
         cfa offs  bind_to_tmpObj
        svHeldMod -> heldMod
    THEN
;


¥ SuperRef handles the  msg: super> someSuper  construct.

: SUPERREF { selID ¥ ^nway namedClass ^nway' cnt -- }
    ?class                            ¥ Must be compiling a class
    '  -> namedClass                ¥ get named class xt
    ^comp_class sfa -> ^nway
    ^nway -> ^nway'  0 -> cnt
    BEGIN
        ^nway' @ 0= ?error 120            ¥ "superclass" not found
        ^nway' @abs namedClass =
    NWHILE
        1cell ++> ^nway'  1 ++> cnt
    REPEAT
    cnt -> supers_to_skip
    selID  ['] sup  $ FFFE  0  ivarRef        ¥ equivalent to msg: super
;

forward COMPREF

¥ PubIvarRef handles the  msg: ivar> someIvar IN someObj  construct, to
¥  send a message directly to a public ivar in an object.  At this point
¥  we've just read "ivar>".

: PUBIVARREF  { selID ¥ addr len ^class ^ivar -- }
    selID -> pivSel                    ¥ save selID being sent to the ivar
    mword hash  -> pivar            ¥ parse ivar name
    mword count  -> len  -> addr
    addr len  " IN" s=
    IF    0                 ¥ dummy "selID" for compRef (not a legal selector)
        compRef            ¥ handle whatever object comes after IN.  The
                        ¥  zero selector signals that a public ivar in the
                        ¥  indicated object is to be accessed - real selectors
                        ¥  can't ever be zero.  This will lead to fix_pivar
                        ¥  being called to complete the job.
    ELSE
        addr len " IN_CLASS" s=
        IF        public_static_ivar_ref
        ELSE    true ?error 194        ¥ "wrong syntax for public ivar"
        THEN
    THEN
;


¥ LBselfRef handles messages to [self] - i.e. late bound to Self.

: LBSELFREF
    postpone self  postpone (defer)  ,
;

¥ Since any class with a late-bound message to self MUST be general, we
¥  used to force it to general at this point.  But since class Object
¥  now has a call to [self] in deep_classinit:, this got us rapidly
¥  into crash territory!  So just remember the general when it's needed.


: COMPDFR    ¥ (selID cfa -- )
    (comp)  postpone (defer)  ,  ;


¥ Now here are the main words which compile the selector bindings.

¥ CompRef operates at compile time - it compiles a selector bind.

:f COMPREF        ¥ ( selID -- )

    refToken    ¥ ( selID <various> type )
                ¥    <various> will be the cfa of whatever came after the selector,
                ¥    or ( offset ^ivar ) for ivars and temp objects (which are
                ¥    treated as ivars of the class Dummy).

    CASE
        objTyp        OF  objRef                            ENDOF
        ivarTyp        OF    ivarRef                            ENDOF
        objPtrTyp    OF  objPtrRef                        ENDOF
        tmpObjTyp    OF  tmpObjRef                        ENDOF
        classTyp    OF    classRef                        ENDOF

¥ These next 3 can only come up if implicit_late_bind? is true:
        valTyp        OF  compdfr                            ENDOF
        locTyp        OF  compdfr                            ENDOF
        wordTyp        OF  compdfr                            ENDOF

        lbTyp        OF  drop  postpone (defer)  ,        ENDOF
        lbSelfTyp    OF  drop  LBselfRef                    ENDOF
        bktTyp        OF  drop  -> dfrSelID  251            ENDOF
        superTyp    OF    drop  superRef                    ENDOF
        pubIvarTyp    OF    drop  pubIvarRef                ENDOF

        82 die                        ¥ "Selector can't be used on that"

    ENDCASE  ;f


(*
RunRef is the execution mode equivalent - it executes a selector bind.
We do this simply by compiling it in a buffer then executing it there.
This replaces the earlier scheme where we had to separately handle each
case as for compRef - this was a Neon carryover.

While we're compiling in the buffer, we save the DP on the return stack,
then restore it before executing what we compiled (since it might do some
compiling itself).  This isn't long, but it's a bit tricky:
*)

    variable    runRefBuf    56 reserve    ¥ allows 4 nested binds - worst case
                                        ¥  14 bytes each
0    value        bufPtr
0    value        hiDP

: RUNREF  { selID ¥ svDP svBufPtr svState -- }
    DP -> svDP                ¥ save DP
    DP hiDP umax -> hiDP    ¥ so we can reset DP to right place on an error

    bufPtr NIF  runRefBuf  ELSE  bufPtr  THEN
    dup -> DP  -> svBufPtr    ¥ now we'll compile in runRefBuf
    state -> svState        ¥ save state
    postpone ]            ¥ need compile state so this compilation works properly
    selID compRef        ¥ compile the binding
    postpone (exit)        ¥ and an exit, so we return to interpretation
    svState -> state    ¥ restore state
    0 -> hiDP            ¥ don't need it any more and could cause problems
    ?unholdMod
    DP -> bufPtr        ¥ new bufPtr value
    svDP -> DP            ¥ restore DP since the code might compile something
    patches_done        ¥ we're about to execute what we just compiled
    svBufPtr execute    ¥ execute at old bufPtr location
    svBufPtr -> bufPtr    ¥ then restore old bufPtr
;


¥                ======== Selector support =========


¥ MESSAGE is the handling word invoked by using a selector.

: MESSAGE        immediate
    state
    IF                      ¥ Compile state
        compRef                ¥ Compile the message send
        ?unHoldMod
    ELSE
        runRef                ¥ Run state - execute object/vector reference.
                            ¥ ?unHoldMod is called by ex-method at the
                            ¥ end, so we don't need to call it here.
    THEN  ;


¥ 1stFind lumps together all the special cases we have to look for after
¥ we've parsed an input word, but before we can do a regular dictionary
¥ lookup.  At present these are selectors, named parms/locals, ivars
¥ and local objects.  If we invent more later, they can easily be added.
¥ The vector Ufind is then set to this word so it is called before the
¥ regular dictionary search.  If we succeed here, we return the selector
¥ ID or zero, the cfa of the handling word, and 1 or -1 (this will cause
¥ FIND to exit without doing anything more).  If we fail, we return the
¥ original string address and false.

: 1stFIND    ¥ ( str-addr -- selID message-cfa T  |  -- str-addr F )
    sel?                        ¥ is it a selector?
    IF        hash                ¥ yes - leave selID
            ['] message  1        ¥  and cfa of message, and 1 (it's immediate)
    ELSE    LocFind                ¥ no - look for the various kinds of local name
    THEN  ;


' 1stFind -> Ufind

getSelect classinit:  -> initID


forward DUMP


¥ SET_CLASS is a utility word used to patch nucleus objects when their classes
¥ are defined in higher-level files.  Actually it could be used to change the
¥ class of any object, if anyone is silly enough to want to do that.

¥ Usage:  fFcb  ['] file  set_class

: SET_CLASS  { ^obj theClass -- }
    theClass  chkClass  ^obj 6 -  reloc!        ¥ Patch ^class
    6  ^obj 8 -  w!                    ¥ Not indexed (yet)
    -6 ^obj  2-  w!  ;                ¥ ^class offset


: CHKSAME        ¥ ( ^obj -- ^obj )
        ¥ A check that two objects are of exactly the
        ¥ same class.
    dup >classXt  ^base >classXt  <> ?error 87  ;


¥            ========= Object pointers ==========

¥ Object pointers are low-level objects (like VALUEs) which point to a
¥ normal (high-level) object, and which allow early-bound messages to be
¥ sent to the object by syntactically sending them to the object pointer.

¥ The normal syntax is

¥  ObjPtr  ZZZ    class_is  someClass

¥ Thereafter, any messages sent to zzz are early-bound to the object that
¥ zzz points to at the time the message executes.

¥ If you need to declare the object pointer before the class exists, use
¥ SET_TO_CLASS once the class is defined, thus:
¥
¥ :class  SOMECLASS    super{ object }
¥
¥    ' someOP  set_to_class  someClass
¥
¥    etc.


true    value    check_OP_stores?    ¥ allows us to turn off type checking
                                    ¥  for stores to objPtrs

: (ToOP)  { ^obj OPcfa ¥ OPcl -- }

    ^obj  nilP =                ¥ If we're storing nil, anything goes
    check_OP_stores? not or        ¥ Or if checking is turned off
    NIF
        OPcfa 4+ @abs  -> OPcl
        ^obj 6 - @abs  OPcl  <>
        IF                      ¥ Mismatch. We give some useful(?) info.
            cr  ^obj obj> .id ."  -> "  OPcfa .id
            87 die
        THEN
    THEN
    ^obj OPcfa !  ;


:f  ToObjPtr
    state
    IF  lit-addr  postpone (toOP)  ELSE  (toOP)  THEN  ;f


: CLASS_IS    ¥ ( --< class > )
    ?exec  '  chkClass  here 4-  reloc!  ;


: SET_TO_CLASS  { ^objPtr ¥ ^cl --< class > }
    '  -> ^cl
    ^objPtr hdlr -62 <> ?error 85        ¥ "That isn't an ObjPtr"

            ¥ Now if "class" is an imported word, we change the handler code
            ¥ to "imported class".  This is normally done when the module
            ¥ is compiled, but it may not be yet, since we probably
            ¥ want to refer to the ObjPtr in the module.

    ^cl hdlr -92 = IF  -90 ^cl 2- w!  ELSE  ^cl chkClass drop  THEN
    ^cl  ^objPtr 4+  reloc!  ;


¥ If you are late-binding in a loop, it can be much faster if you do the bind
¥ just once, then reuse the resulting cfa each time in the loop.  This way
¥ you only have to perform the method search once.  To bind initially and get
¥ the cfa, use

¥  BIND_WITH ( ^obj --<selector> ^obj-modified  cfa )

¥ Usage:  (saveCfa and ^obj-mod are values or locals)

¥    (get object's address)  bind_with someSelector:  -> saveCfa  -> ^obj-mod

¥    (in the loop)  ^obj-mod  saveCfa  ex-method

¥ The use of the modified object address is a bit obscure, and is related to
¥ multiple inheritance.  The method you actually end up binding to may be in
¥ one of the superclasses, and the ivars for that superclass may not start at
¥ the beginning of the object.  The modified object address is the start of
¥ the ivars for the superclass, which is the address the method needs.

¥ Note also that the method may turn out to be in a module, so when you have
¥ finished you should put ?unHoldMod to free up the module.

: (BWITH)  { ^obj selID ¥ cfa offs -- ^obj-modified  cfa }
    selID ^obj ?>class  clFindm
    drop ( %%%% )
    -> offs  -> cfa
    ^obj offs +  cfa  ;


: BIND_WITH        ¥ ( ^obj --<selector> ^obj-modified  cfa )
    getSelect  postpone literal
    postpone (bwith)  ;        immediate


¥        ===================================

:class    OBJECT    super{ meta }

:m CLASS:    ^base ?>class ?>classinMod  ;m

:m .ID:        ^base obj>  .id  ;m

:m .CLASS:    ^base >classXt  .id  ;m

:m ADDR:    inline{ ^base}  ;m
¥        ^base  ;m

:m ABS:        ^base  ;m        ¥ Included for Neon/Yerk compatibility

:m LENGTH:    ¥ ( -- len )  Gets total length of object.
    objlen  ;m


(*    Here are two methods which operate between this object and another of
    the same class.  Note we don't check that the passed-in object is actually
    of the same class, since it could be a subclass but still be safe to use
    here.
*)

:m COPYTO:    ¥ ( ^obj -- )  Copies the ivar part of the passed-in object
            ¥ to self.
    ^base  dup (^dlen) w@  aligned_move  ;m

:m =?:        ¥ ( ^obj -- b )  Returns true if the ivar part of the passed-in
            ¥ object is identical to self.
    ^base  dup (^dlen) w@  (s=)  ;m

(*    The following methods need to be defined for all objects.
    We give them their default definitions here.
*)

:m CLASSINIT:  ;m    ¥ Our standard constructor method.  Called automatically
                    ¥ whenever an object is created.


:m DEEP_CLASSINIT:    ¥ Also does classinit: on all nested ivars.  Use for
                    ¥  totally (re-)initializing an object.
    ^base -> newObject
    class: self ifa displace  0  0
    ivSetup
¥    classinit: [self]
    ?unholdMod  ;m


(*    RELEASE: is our standard destructor method.  Any objects that
    allocate heap storage will redefine this appropriately.
    Our convention is that an object will release ALL its
    storage when it gets a release: message. Other methods
    can be provided to partly release storage, as needed.
*)

:m RELEASE:    inline{ }  ;m


:m DUMP:
    .id: self  ."  class: "  .class: self
    ^base  objlen  dump  ;m

:m PRINT:        ¥ Used for a formatted display, if appropriate.
                ¥ Default is just a dump.
    dump: self  ;m

;class


¥ Bytes is used as the allocation primitive for basic classes

: BYTES  { numBytes ¥ svRec? -- }
    ?class
    rec? -> svRec?  true -> rec?    ¥ Don't want an object header here
    ['] object ivDef
    numBytes  ^comp_class dfa  w+!
    svRec? -> rec?  ;



(*        ================  Temp (local) objects  ===================

    Syntax:

    : aWord  { loc1 loc2 -- }        ¥ Locals are optional, of course
        temp
        {    var        v1
            int        i1
            string    s
        }

    Or you can use temp{ ...  } if you prefer.

    As the syntax is quite similar to a list of ivars of a class, we actually
    implement the temp objects as though they're the ivars of a dummy class
    (which we uncreatively call Dummy).  This is just a convenience during
    the compilation of a defn with temp objects.  It allows us to define them
    and keep them visible during the compilation of the definition, while
    being able to mainly use existing code for ivar access.  We don't need
    these ivar dic entries once the defn is finished, so we actually put them
    high in the dictionary out of the way of the defn we're compiling.  At
    the end of the defn, we reinitialize Dummy's ivar link ready for next time.
*)

getSelect release:        constant    releaseID


:class DUMMY  super{ object }
;class

' dummy ifa @    constant    dummyIfa
            ¥ ivar link corresponding to no ivars - it will be a relative
            ¥  pointer to the n-way for the superclass, and thus a constant

: RESETTEMPS
    dummyIfa  ['] dummy ifa  !
    0  ['] dummy dfa !                ¥ clear dlen and xwid
;

    ¥ Note we don't have to worry about the mfa since Dummy never gets
    ¥ its own methods.


(*    InitTemps is called when we're compiling the prolog for a definition
    with temp objects.  It compiles a call to make_obj for each object, so
    that they're properly initialized.  Note we can't just call make_obj once
    using class Dummy, since its ivar list is wiped out after each defn
    with temp objects, so at run time it won't have any!  But we don't need
    Dummy at run time anyway - we only need the "ivars" which are the
    temp objects themselves.
*)

: 1TEMP  ( ^iclass ioffs -- )
    locReg +  make_obj  ;


:f INITTEMPS  { ¥ infa ^class -- }
    ['] dummy ifa displace  -> infa
    BEGIN
        infa @ 0<
    WHILE
        infa ^iclass -> ^class
        ^class xwid
        IF        ¥ it's indexed - we'll have #elements on the stack,
                ¥  so we need to compile it as a literal for
                ¥  make_obj to grab at run time.
            infa i#els  postpone literal
        THEN
        ^class lit-addr
        infa ioffs  postpone literal
        postpone locreg  postpone +  postpone make_obj
        infa ^nextivar  -> infa
    REPEAT  ;f


(*    ReleaseTemps is called back from Handlers when it's compiling an exit.
    It compiles a release: xxx for all temp objects.  Because of the way
    we've defined release: in class Object, for simple objects no code will
    actually be generated.

    Note we mustn't call resetTemps here since this might be an EXIT, not
    the final semicolon.  We leave calling resetTemps till a new temp{ comes
    up.
*)

: RELEASETEMPS  { ¥ infa -- }
    ['] dummy ifa displace  -> infa
    BEGIN
        infa @ 0<
    WHILE
        infa  ^iclass  0EXIT            ¥ shouldn't happen, actually
        releaseID  infa  ivFindM 2drop
        infa ioffs bind_to_tmpObj        ¥ compile release:
        infa ^nextivar  -> infa
    REPEAT
;


: }TEMP
    130 ?pairs
    ['] } >body !                        ¥ restore old action for "}"
    -> ^comp_class  -> state  -> cstate  -> DP    ¥ restore other things
    tmpObjs dlen 8 +  -> frameSize        ¥ work out frame size
    local? NIF                            ¥ compile prolog unless we're in
        PLentry  initTemps                ¥  a local section (then it gets done
    THEN                                ¥  by :LOC)
    ['] releaseTemps -> relTmps            ¥ for Handlers callback at exit time
;


: TEMP{        immediate

(*    First we have to allocate an internal local variable as a frame pointer.
    There are 4 situations.  There may or may not already be locals, and
    we may or may not be in a local section.  Note we can be in a local
    section even if there aren't already locals, since the purpose of the
    local section might be just to establish a section for these temp objects.

    If there are already locals, we just add another.  If we're not in a
    local section we need to recompile the entry sequence (done by PLentry)
    since the number of regs to be saved and set up is different.  But if
    we're in a local section, we don't have to recompile since we haven't
    called PLentry yet, so we just add the extra local.  If there aren't any
    locals already, we just call initLocs which sets them up, before adding
    the new one.
*)
    resetTemps
    #PL IF
        local?    NIF  PLentry_addr -> DP  THEN
    ELSE
        initLocs                ¥ No locs before, so set up for them now
    THEN
    local? IF  -1 -> local?  THEN    ¥ If in a local section, setting local?
                                    ¥ to -1 means we've defined the locals
                                    ¥ so can't do it again
    " x " here place  here addToParmList

(*    next we save DP and move halfway up in the free dic space - we'll put
    the "ivar dic entries" for the temp objs there - we don't need them
    after the defn is compiled.
*)
    here            room 2/ ++> DP  align-dp
    cstate            true -> cstate
    state
    ^comp_class
    ['] } >body @                ¥ save old action for "}"
    ['] }temp  -> }                ¥ "}" will now be same as }temp
    130                            ¥ for ?pairs

    ['] dummy dup    -> ^comp_class    ¥ local objs will look like ivars of Dummy
                    -> tmpObjs        ¥ this will enable finding them



    postpone [                    ¥ stop compiling
;


: TEMP        gobble{  postpone temp{  ;        immediate


(*        =================  Records and unions  ====================

Syntax:

    record <name>        ¥ The name is optional
   {    var        v1
        int        i1
        string    s
   }

       union <name>        ¥ The name is optional
   {    var        v1
        int        i1
        string    s
   }


Or you can use record{ ...  } or union{ ... } if you prefer, if it's
unnamed.  The similarity of syntax to temp objects is quite deliberate.
But any similarity to Your Favorite Language is entirely accidental.  Well
actually it's not, but I think this syntax is as good as any, and probably
more readable for folks coming from the land of C.

unions can be nested within records and vice versa.

NOTE: it's best to not use unions unless you're really sure you know what
you're doing.  Having different objects sharing the same memory is sure
to cause problems if you're careless!

*)

: SVREC
   ^comp_class dfa w@
    rec?
    union?
    unionOffs
;

: RSTREC
    -> unionOffs
    -> union?
    -> rec?
    union? IF     ¥ we fell back in a union, so we
                ¥ reset data pointer to were it was at the beginning
                ¥ of this union/rec
        ^comp_class dfa w!
    ELSE
        drop
    THEN
;

: ?HANDLE_NAME  { ¥ sv_>in sv_^class sv_rec? -- }
    >in @ -> sv_>in ^comp_class -> sv_^class  rec? -> sv_rec?
    Mword  count  " {" s=
    NIF                            ¥ we've got a name for the record
        true -> rec?            ¥ must do this before defining the name "object"
        sv_>in  >in !
        ['] object  ivDef
        sv_rec? -> rec?  sv_^class -> ^comp_class
        gobble{                    ¥ "{" must follow
    THEN
;


: }RECORD
    131 ?pairs  rstRec
    ['] } >body !  ;


: RECORD{
    ?class                        ¥ must be compiling a class
    ['] } >body @                    ¥ save old action for "}"
    ['] }record  -> }            ¥ "}" will now be same as }record
    svRec                        ¥ save parameters for any existing record/union
    131                            ¥ for ?pairs
    true -> rec?  false -> union?  ;

: RECORD
    ?handle_name
    record{  ;

: 68k_record{    record{  ;        ¥ we need to distinguish on the PowerPC
: 68k_record    record   ;


: }UNION
    132 ?pairs
    unionOffs  ^comp_class dfa w!
    rstRec
    ['] } >body !  ;                ¥ restore old action for "}"

: UNION{
    ?class                        ¥ must be compiling a class
    ['] } >body @                    ¥ save old action for "}"
    ['] }union  -> }            ¥ "}" will now be same as }union
    svRec                        ¥ save record/union parameters
    132                            ¥ for ?pairs
    true -> rec?  true -> union?
    ^comp_class dfa w@ -> unionOffs  ;


: UNION
    ?handle_name
    union{  ;


(*        =================  Static ivars ====================

Syntax:

    static
   {    var        v1
        int        i1
        string    s
   }

Or you can use  static{ ...  } if you prefer.

These are like static class variables in C++ - they belong to the class,
not the object, and thus are shared by all objects of the class.  We
allocate each ivar in the dictionary right after its ivar header.
*)

: }STATIC
    133 ?pairs
    ['] } >body !                    ¥ restore old action for "}"
    false -> static?  ;


: STATIC{
    ?class                        ¥ must be compiling a class
    ['] } >body @                ¥ save old action for "}"
    ['] }static  -> }            ¥ "}" will now be same as }static
    133                            ¥ for ?pairs
    true -> static?  ;

: STATIC
    gobble{  static{  ;


¥            ==========================================

¥ CL1 is our first cleanup word - called on an abort.  Resets things
¥  to normal.  Later cleanup words do their special stuff, then call CL1.

: CL1
    (;cl)  clrComp  ['] (}) -> }
    resetTemps  false -> rec?  false -> union?
    false -> compinline?
    0 -> extraFind
    0 -> bufPtr
    DP hiDP umax  -> DP
    false -> case_in_names?
;

' cl1  -> abortVec


load Struct

¥            ==========================================

(* Normally we don't get here.  In order to do various tests on classes,
 we comment out the  <" Struct  and run these torture tests:
*)

: ?CHK    <> abort" check FAILED!!!"  ;    ¥ error if something doesn't
                                        ¥  give what we expect


:class    VAR    super{ object }

    4 bytes data

:m CLEAR:
    inline{ 0 ^base !}  ;m
¥    0 ^base !  ;m

:m GET:
    inline{ ^base @}  ;m
¥    ^base @  ;m

:m PUT:
    inline{ ^base !}  ;m
¥    ^base !  ;m

:m GETT:    ^base @  ;m

:m PUTT:    ^base !  ;m

:m +:
    inline{ ^base +!}  ;m
¥    ^base +!  ;m
:m -:
    inline{ ^base -!}  ;m
¥    ^base -!  ;m
:m ->:
    inline{ @ ^base !}  ;m
¥    chksame  get: var  put: self  ;m

:m TEST:        db  ;m

mlocal LOCTEST:  { aa ¥ bb cc -- }

:m AAA:    aa -> bb ;m

:mloc  LOCTEST:
    aaa: self  cc -> bb  1234 drop ;mloc


:m PRINT:
    ^base @  .  ;m

:m CLASSINIT:    $ 123  put: self  ;m

;class


:class    BYTE    super(  object  )

    1 bytes data

:m CLEAR:
    inline{ 0 obj c!}
    0 ^base c!  ;m

:m GET:
    inline{ obj c@x}
    ^base c@x  ;m

:m UGET:
    inline{ obj c@}
    ^base c@  ;m

:m PUT:
    inline{ obj c!}
    ^base c!  ;m

:m ->:
    inline{ c@ obj c!}
    chksame  c@  put: self  ;m

:m PRINT:
    ^base c@  .        ;m

:m CLASSINIT:    9 put: self  ;m

;class

¥ some very simple testing, to start with:

var        aVar
byte    aByte

987 avar !
get: avar    987 ?chk
: q  get: avar  ;
q            987 ?chk


:class    BOOL    super(  byte  )

:m GET:
    inline{ obj c@x}
    ^base c@x  ;m

:m PUT:
    inline{ 0<> obj c!}
    0<>  ^base c!  ;m

:m SET:
    inline{ true obj c!}
    true ^base c!  ;m

:m PRINT:
    get: self  IF  ." true"  ELSE  ." false"  THEN  ;m

:m CLASSINIT:    clear: self  ;m

;class


:class    BARRAY  super{ object }  1 indexed

:m  AT:        ¥ ( index -- n )
    inline{ ix c@}
    ^elem1  c@  ;m

:m  TO:        ¥ ( n index -- )
    inline{ ix c!}
    ^elem1  c!  ;m


:m ^ELEM:    ¥ ( index -- addr )
    inline{ ix}
    ^elem1  ;m

:m FILL:    ¥ ( value -- )  Fills all elements with value.
    idxbase  limit 2*  bounds
    ?DO  dup  i c!  LOOP  drop  ;m

:m WIDTH:    1  ;m        ¥ Faster than the default in Object

:m GETELEM:    ¥ ( addr -- n )  Fetches one element at addr
    c@x  ;m

;class


+echo

¥ bug test here:

:class    INDEXED-OBJ  super{ object }

:m ^ELEM:    ^elem  ;m

:m LIMIT:    limit  ;m

:m WIDTH:    idxbase  6 -  w@  ;m

:m IXADDR:    idxbase  ;m

:m CLEARX:    ¥ Erases indexed area.
    idxbase  limit  width: self  *  erase  ;m

:m CLASSINIT:    clearX: self  ;m

;class


:class    WARRAY  super{ indexed-obj }  2 indexed

:m AT:        ¥ ( index -- n )
    inline{ ^elem w@x}  ;m

:m TO:        ¥ ( n index -- )
    inline{ ^elem w!}  ;m

;class


:class  TRIGTABLE    super{ wArray }

    3    wArray  AXISVALS
;class

10 trigtable ttt

: q  9 at: ttt  ;


¥ Testing static and public ivars


:class SIVTEST  super{ var }
public
static
{    var        V1
    bool    B1
    byte    B2
10    barray    BB
}
    bool    BLOC
    var        VLOC

:m QQ:    get: v1  get: b1  get: b2 4 at: bb
        get: vloc  ;m

:m CLASSINIT:
        32 put: v1  set: b1  33 put: b2  34 4 to: bb
        set: bloc  34 put: vloc  ;m
;class

sivtest zzz
sivtest sss
objPtr myop  class_is sivtest

: QQQ        addr: ivar> v1 in_class sivtest  drop
            get: ivar> b2 in_class sivtest
            get: ivar> v1 in_class sivtest
            sss get: ivar> bloc in class_as> sivtest  ;

qqq
-1    ?chk
32    ?chk
33    ?chk


:class HAHA  super{ object }

    sivtest    IVsss

:m QQ:      get: ivar> vloc IN ivsss  ;m
;class

haha hh

qq: hh
34 ?chk

: WWW  temp { sivtest mysiv }
    get: ivar> vloc IN mysiv
    mysiv -> myop
    get: ivar> vloc IN myop  ;

www
34 ?chk
34 ?chk

    get: ivar> vloc IN zzz
34 ?chk


¥ Testing record{

:class VAR+ super{ var }

:m QQ:    get: [self]        ¥ should make class general
        get: [ self ]    ¥ shouldn't give any error
;m

;class

var+ VVV
qq: vvv        ¥ no need for ?chk since it will give its own error


:class RECTEST super{ object }
    var    vv
    record RR
    {        var        v1
            bool    b1
        3    barray  bbb
            byte    dummyToMakeAddrOdd
        union {    byte    b2
                var        v2
                record    {    byte bb1
                            byte bb2    }
            }
            var        v3
    }

:m TEST:
    get: v1  put: b1  get: b2  get: v2  get: bb1  get: bb2  get: v3
;m
;class

recTest rrr
test: rrr
$ 123        ?chk
0            ?chk
9            ?chk
$ 09000123    ?chk
9            ?chk
$ 123        ?chk
$ 123        ?chk

rrr $ 24 + @  $ 09000123  ?chk

¥ Testing temp objects

: q
temp
{    var    v1
     var    v2
}temp
    v1 v2
    get: v1  get: v2  ;

q
$ 123    ?chk
$ 123    ?chk
2drop

:class INT  super( object )

    2    bytes    data

:m CLEAR:
    inline{  0 obj !  }
    0 ^base !  ;m

:m UGET:
    inline{  ^base w@  }
    ^base w@  ;m

:m GET:
    inline{  obj w@x  }
    ^base w@x  ;m

:m IPUT:    ^base w!  ;m

:m DISP:
    inline{  obj 2+ @  }  ;m

:m PUT:
    inline{  obj w!  }
    ^base  w!  ;m

:m MOVE:
    inline{  obj 4+ w@  obj w!  }  ;m


:m +:    inline{  obj w+!  }
    ^base  w+!  ;m

:m ->:
    inline{  w@ obj w!  }
    chksame  1234 drop  get: int  put: self  ;m

:m ++>:
    inline{  w@ obj w+!  }
    chksame  uget: int  +: self  ;m

:m .ID:    ." haha"  ;m

:m TEST:
    1234 drop  .id: super  ;m

:m CLASSINIT:    $ 456 put: self  ;m

;class


:class CC  super{ byte int var bool }

:m TEST:
    uget: self        ¥ offs should be 0
    +: self                ¥ offs should be 4
    set: self  ;m        ¥ offs should be A

:m TEST1:
    set: self
    get: super> bool    ¥ should get -1
    get: super
;m

:m classinit:  ( db )  ;m

;class

cc CCC

ccc @        $ 0900fff6    ?chk
ccc 4+ @    $ 0456fff2    ?chk
ccc 8 + @    $ 123        ?chk


:class STRANGE  super{ object }
    var VV
    byte BB
:m GET:  get: vv  get: bb  ;m
:m PUT:  put: bb  put: vv  ;m

;class


:class    ARRAY    super(  object  )    4 indexed

¥ 8 bytes data        ¥ Comment out to check collapsing of embedded objs

:m ^ELEM:    ¥ ( index -- addr )
    ^elem4  ;m

:m QQQ:    inline{ ix }  ;m

:m  AT:        ¥ ( index -- n )
    inline{ ix @ }
    ^elem4  @  ;m

:m  ATT:    ^elem  @  ;m        ¥ As for AT:, but not inline
                ¥  and uses unoptimized ^elem

:m  TO:        ¥ ( n index -- )
    inline{  ix !  }
    ^elem4  !  ;m

:m  +TO:        ¥ ( n index -- )
    inline{ ix +! }
    ^elem4  +!  ;m

:m -TO:        ¥ ( n index -- )
    inline{ ix -! }
    ^elem4  -!  ;m

:m FILL:        ¥ ( value -- )  Fills all elements with value.
    idxbase  limit 4*  bounds
    DO  dup  i !  4 +LOOP  drop  ;m

:m EXEC:        ¥ ( index -- )  execute the cfa, by jumping there.
    inline{ ix ex}
    ^elem: self  execute  ;m

:m TEST:
    exec: self  ;m

:m ATEST:
    1 at: self  ;m

;class


:class MULT    super( var int array )

:m MTEST:    uget: super  999 1 to: self  ;m
:m MAT:        at: self  ;m
;class


objPtr    OO    class_is mult
objPtr    OOO    class_is int

:class IVXX    super( object )
    10 bytes data2
    int    i1
    int    i2
    130 bytes qqqq        ¥ Include to check >128 distance
                        ¥  index addressing of array qwert
    9 array qwert

:m ITEST:
    get: i1  uget: i2  66 put: i2
    99 3 to: qwert  1234 drop  3 at: qwert
    addr: i2  ['] ooo !  ;m

:m GETQWERT:
    addr: qwert  ;m
;class

int ii
3 mult    mm
ivxx    iv

mm -> oo

itest: iv

$ 63    ?chk
$ 456    ?chk
$ 456    ?chk

mtest: mm
$ 456    ?chk

88 iput: mm        ¥ Note: get: mm will bind to the var, but uget: mm
                ¥ will bind to the int and give 88.

get: mm  $ 123    ?chk
uget: mm 88        ?chk


¥ A further test - Doug H found this bug:

:class  POINT    super{ object }
    int    Y        ¥ Vertical coordinate
    int    X        ¥ Horizontal  coordinate
;class


:class  RECT  super{ object }
    point    TOPL
    point    BOTR
;class

:class test1 super{ object }

    20 array a

:m classinit:
    55 0 to: a ;m

:m to:  to: a ;m

:m at:  at: a ;m

;class

:class test3 super{ rect test1 }
:m classinit:
    [ 1 -> supers_to_skip ]  classinit: super
;m
;class

test3 t3

: q            getqwert: iv  3 swap at: **  ;    ¥ Should give 99
: qq        1 at: mm ;                        ¥ Should give 999
: qqq        1 mat: mm  ;                    ¥ Should give 999
: qqqq        1 mm at: mult  ;                ¥ Should give 999
: z            1 mm at: **  ;                    ¥ Should give 999
: zz        1 mm at: array ;                ¥ Should fail
: y            1 at: oo   ;                    ¥ Should give 999
: yy        1 mat: oo  ;                    ¥ Should give 999
: yyy        uget: mm  ;                        ¥ Should optimize & give 88
: yyyy        addr: mm  addr: oo  ;            ¥ Both numbers shd be same
: yyyyy        uget: ooo  ;                    ¥ Should give 66
: yyyyyy    0 at: t3  ;                        ¥ Should give 55


q         99    ?chk
qq         999    ?chk
qqq     999    ?chk
qqqq     999 ?chk
z         999    ?chk
y         999    ?chk
yy         999    ?chk
yyy     88    ?chk
yyyy        ?chk
yyyyy     66    ?chk
yyyyyy    55    ?chk

¥ torture tests WORKED!  INCREDIBLE!!  CONGRATULATIONS!!!
¥ (but remember to check that ZZ gives a "can't use indexed method" error)
key!